perm filename GOBBLE.SAI[AL,HE]9 blob
sn#368756 filedate 1978-07-20 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00020 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 IFCR ¬DECLARATION(EXTENDED_COMPILATION) THENC
C00005 00003 SIMPLE INTEGER PROCEDURE STINDX(STRING SINTEGER CH)
C00006 00004 CHANNEL STUFF: readfile, writefile
C00008 00005 ! Definitions
C00010 00006 ! rwdo, rwmake, dirmake, codemake, dtypmake, inpinit
C00019 00007 ! nextline, inscan, skipblanks, scan_token
C00023 00008 ! read and fread
C00026 00009 ! get_dtype, verify_dtype, verify_1, verify_2, verify_3, dtype_check
C00037 00010 ! asgbki, identlookup, ensym, vblmake, vtry, mkblkbody
C00043 00011 ! grovel (lllop, gllop, widget, stgrovel, lgrovel, constelim)
C00048 00012 ! grovel: REGROVEL: DIR, EOP, DTYP
C00051 00013 ! grovel: DTYP: ARRAY, PROCEDURE
C00057 00014 ! grovel: main body: PROG,BLOCK,COBLOCK,FORR,WHIL,IFF,PAUSE,ABORT,CIF,COMMNT
C00061 00015 ! grovel: main body: CASE, RETURN
C00065 00016 ! grovel: main body: NOMV, BINDV, DBD, NW, PVL, ASSERT, DENY, AFACT, SFACT
C00068 00017 ! grovel: main body: AFFIX, UNFIX, GASSIGN, CALCULATOR, CHANGER, ALSODO, SPECVAL
C00072 00018 ! grovel: main body: V3ECT, TRANS, ASSIGNMENT, EVDO, PRNT
C00076 00019 ! grovel: main body: MOVE$, OPERATE, CENTER, STOP, motion clauses
C00085 00020 ! MAIN PROGRAM
C00086 ENDMK
C⊗;
IFCR ¬DECLARATION(EXTENDED_COMPILATION) THENC
ENTRY;
BEGIN "GOBBLE"
IFCR ¬DECLARATION(CREFFING) THENC DEFINE CREFFING="FALSE"; ENDC
IFCR ¬ CREFFING THENC
REQUIRE "ALREQ.HDR[AL,HE]" SOURCE_FILE;
ENDC
REDEFINE $$PRGID "[]" = ["GOBBLE"];
ENDC
REQUIRE 1500 NEW_ITEMS;
RCLASS RESERVED_WORD(ITEMVAR RWSYM;INTEGER RWTYPE;INTEGER CODE);
! RCLASS STCONST(STRING ITEMVAR VAL). This is now in ALREC. RF 3/23/76;
RCLASS IVAR(ITEMVAR IVAR);
DEFINE DSKIN_OP = 1;
DEFINE INIOUT_OP = 2;
SIMPLE INTEGER PROCEDURE STINDX(STRING S;INTEGER CH);
START_CODE
LABEL XIT,LP;
DEFINE SP='16;
MOVEI 1,0;
HRRZ 2,-1(SP);
JUMPE 2,XIT;
MOVE 3,(SP);
MOVE 4,CH;
LP: ADDI 1,1;
ILDB 5,3;
CAMN 5,4;
JRST XIT;
SOJG 2,LP;
MOVEI 1,0;
XIT: END;
COMMENT CHANNEL STUFF: readfile, writefile;
DEFINE MAXFILES="15";
STRING ARRAY FID[0:MAXFILES];
INTEGER ARRAY EOF[0:MAXFILES];
INTEGER ARRAY BRCHAR[0:MAXFILES];
INTEGER PROCEDURE READFILE(STRING FILEID;INTEGER DMODE(0));
BEGIN
INTEGER CH;
CH←GETCHAN;
FID[CH]←FILEID;
OPEN(CH,"DSK",DMODE,3,0,512,BRCHAR[CH],EOF[CH]);
LOOKUP(CH,FILEID,EOF[CH]);
IF EOF[CH] THEN
BEGIN
USERERR(1,1,"LOOKUP FAILED FOR |"&FILEID&"|");
RELEASE(CH);
CH←-1;
END;
RETURN(CH);
END;
INTEGER PROCEDURE WRITEFILE(STRING FILEID;INTEGER DMODE(0));
BEGIN
INTEGER CH;
CH←GETCHAN;
CH←GETCHAN;
FID[CH]←FILEID;
OPEN(CH,"DSK",DMODE,0,3,512,BRCHAR[CH],EOF[CH]);
ENTER(CH,FILEID,EOF[CH]);
IF EOF[CH] THEN
BEGIN
USERERR(1,1,"ENTER FAILED FOR |"&FILEID&"|");
RELEASE(CH);
CH←-1;
END;
RETURN(CH);
END;
RCLASS CHAR_REC(INTEGER CHAR);
! Definitions;
DEFINE MAXINPLEV=3;
INTEGER ARRAY SCNCHN[1:MAXINPLEV];
STRING ARRAY SCNSTK[0:MAXINPLEV];
INTEGER INPLEV;
RANY ITEMVAR SYM;
STRING SCNID;
REAL SCNRVAL;
INTEGER SCNIVAL;
INTEGER LINBRK,BLNKBRK,IDBRK,STRBRK;
DEFINE UNKN_CODE = 0; ! Unknown code;
DEFINE IDENT_CODE = -1; ! identifier;
DEFINE VAR_CODE = -2; ! Declared variable **** NOT USED ANY MORE ***;
DEFINE RW_CODE = -3; ! Reserved word;
DEFINE VAL_CODE = -4; ! Scalar value;
DEFINE STR_CODE = -5; ! String constant;
DEFINE DIR_CODE = -6; ! Directive (DSKIN, INIOUT);
DEFINE EOP_CODE = -7; ! Expression operation (SADD ...);
DEFINE DTYP_CODE = -8; ! Declaration (SVAR ...);
DEFINE IV_CODE = -9; ! Itemvar;
DEFINE CONST_CODE = -10; ! Predeclared constant (NILVECT ...);
! rwdo, rwmake, dirmake, codemake, dtypmake, inpinit;
DEFINE GVAL_DTYPE = "0";
PROCEDURE RWDO(STRING ID;INTEGER TYPE,I);
BEGIN
RANY ITEMVAR V;
V←NEW(NEW_RECORD(RESERVED_WORD));
RESERVED_WORD:RWTYPE[∂(V)]←TYPE;
RESERVED_WORD:CODE[∂(V)]←I;
RESERVED_WORD:RWSYM[∂(V)]←V;
NEW_PNAME(V,"$" & ID);
END;
PROCEDURE RWMAKE(STRING ID;INTEGER I);
RWDO(ID,RW_CODE,I);
PROCEDURE DIRMAKE(STRING ID;INTEGER I);
RWDO(ID,DIR_CODE,I);
PROCEDURE CODEMAKE(STRING ID;INTEGER I);
RWDO(ID,EOP_CODE,I);
PROCEDURE DTYPMAKE(STRING ID;INTEGER I);
RWDO(ID,DTYP_CODE,I);
PROCEDURE INPINIT;
BEGIN
SETBREAK(LINBRK←GETBREAK,LF,CR,"INS"); ! line break;
SETBREAK(BLNKBRK←GETBREAK," "&FF&TAB&CR&LF,NULL,"XRN");
SETBREAK(IDBRK←GETBREAK,"ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$",NULL,"KXRN");
SETBREAK(STRBRK←GETBREAK,""""&LF,CR,"INS");
INPLEV←0;
DIRMAKE("DSKIN",DSKIN_OP);
RWMAKE("NULL",0);
RWMAKE("AFFIX",AFFIXTYPE);
RWMAKE("COMMENT",COMMNTTYPE); ! Added by RF;
RWMAKE("ALSO",ALSODOTYPE); ! Added by RF;
RWMAKE("SPEC",SPECVALTYPE); ! Added by RF. NEWV and OLDV;
RWMAKE("ON",CMONTYPE); ! Added by RF;
RWMAKE("EV",EVDOTYPE); ! Added by RF;
RWMAKE("CMABLE",CMABLETYPE);
RWMAKE("UNFIX",UNFIXTYPE);
RWMAKE("PR",PROGTYPE);
RWMAKE("CLC",CALCULATORTYPE);
RWMAKE("CHG",CHANGERTYPE);
RWMAKE("BL",BLOCKTYPE);
RWMAKE("CO",COBLOCKTYPE);
RWMAKE("FO",FORRTYPE);
RWMAKE("WH",WHILTYPE);
RWMAKE("UNTL",UNTLTYPE);
RWMAKE("CASE",KASETYPE);
RWMAKE("IF",IFFTYPE);
RWMAKE("PAUSE",PAUSETYPE);
RWMAKE("PROMPT",PROMPTTYPE);
RWMAKE("ABORT",ABORTTYPE);
RWMAKE("RET",RETRNTYPE);
RWMAKE("AS",ASSIGNMENTTYPE);
RWMAKE("CIF",CIFTYPE);
RWMAKE("PAS",PASTYPE); ! Added by arg - translates to an arith assert;
RWMAKE("ASSERT",ASSERTTYPE);
RWMAKE("DENY",DENYTYPE);
RWMAKE("AF",AFACTTYPE);
RWMAKE("SF",SFACTTYPE);
RWMAKE("MO",MOVE$TYPE);
RWMAKE("OPERATE",OPERATETYPE);
RWMAKE("CENTER",CENTERTYPE); ! Added by RF;
RWMAKE("STOP",STOPTYPE); ! Added by RF;
RWMAKE("DURATION",DURATIONTYPE); ! Added by RF;
RWMAKE("FORCE",FORCETYPE);
RWMAKE("FORCE_FRAME",F_FRAMETYPE);
RWMAKE("SETBASE",SETBASETYPE); ! This and WRIST are temp hacks for JKS;
RWMAKE("WRIST",WRISTTYPE); ! so he can debug the force wrist;
RWMAKE("PRINT",PRNTTYPE); ! Added by RF;
RWMAKE("VIA",VIATYPE); ! Added by RF;
RWMAKE("VELOCITY",VELOCITYTYPE); ! Added by ARG;
RWMAKE("ARRIVAL",ARRIVALTYPE); ! Added by ARG;
RWMAKE("DEPARTURE",DEPARTURETYPE); ! Added by ARG;
RWMAKE("OPENING",OPENINGTYPE); ! Added by ARG;
RWMAKE("WOBBLE",WOBBLETYPE); ! Added by ARG;
RWMAKE("SPEED_FACTOR",S_FACTYPE); ! Added by ARG;
RWMAKE("NNULL",NNULLTYPE); ! Added by ARG;
RWMAKE("EX",EXPRNTYPE);
RWMAKE("VA",VARIABLETYPE);
RWMAKE("SC",SVALTYPE);
RWMAKE("PVL",PVLTYPE);
RWMAKE("NW",NWTYPE);
RWMAKE("DBD",DBDTYPE);
RWMAKE("NOTE",NOTETYPE); ! Added by ARG - for debugging;
RWMAKE("NOTE1",NOTE1TYPE);
RWMAKE("NOTE2",NOTE2TYPE);
RWMAKE("GAS",GASSIGNTYPE);
RWMAKE("NOMV",NOMVTYPE);
RWMAKE("BIND",BINDVTYPE);
CODEMAKE("NOOP",NO_OP);
CODEMAKE("CALL",CALL_OP);
CODEMAKE("AREF",AREF_OP);
CODEMAKE("SSBRTN",SSBRTN_OP);
CODEMAKE("SCALRD",SCALRD_OP);
CODEMAKE("SABS",SABS_OP);
CODEMAKE("SADD",SADD_OP);
CODEMAKE("SSUB",SSUB_OP);
CODEMAKE("SMUL",SMUL_OP);
CODEMAKE("SNEG",SNEG_OP);
CODEMAKE("SDIV",SDIV_OP);
CODEMAKE("SEXP",SEXP_OP);
CODEMAKE("MAX",MAX_OP);
CODEMAKE("MIN",MIN_OP);
CODEMAKE("INT",INT_OP);
CODEMAKE("DIV",DIV_OP);
CODEMAKE("MOD",MOD_OP);
CODEMAKE("QUERY",QUERY_OP);
CODEMAKE("SLT",SLT_OP);
CODEMAKE("SEQ",SEQ_OP);
CODEMAKE("SLE",SLE_OP);
CODEMAKE("SGE",SGE_OP);
CODEMAKE("SNE",SNE_OP);
CODEMAKE("SGT",SGT_OP);
CODEMAKE("AND",AND_OP);
CODEMAKE("OR",OR_OP);
CODEMAKE("NOT",NOT_OP);
CODEMAKE("XOR",XOR_OP);
CODEMAKE("EQV",EQV_OP);
CODEMAKE("VMAGN",VMAGN_OP);
CODEMAKE("VDOT",VDOT_OP);
CODEMAKE("VMAKE",VMAKE_OP);
CODEMAKE("SVMUL",SVMUL_OP);
CODEMAKE("VSDIV",VSDIV_OP);
CODEMAKE("VADD",VADD_OP);
CODEMAKE("VSUB",VSUB_OP);
CODEMAKE("VCROSS",VCROSS_OP);
CODEMAKE("RVMUL",RVMUL_OP);
CODEMAKE("TVMUL",TVMUL_OP);
CODEMAKE("AXIS",AXIS_OP);
CODEMAKE("RMAGN",RMAGN_OP);
CODEMAKE("UVECT",UVECT_OP);
CODEMAKE("POS",POS_OP);
CODEMAKE("ORIENT",ORIENT_OP);
CODEMAKE("RRMUL",RRMUL_OP);
CODEMAKE("AXW_ROTN",AXW_ROTN_OP);
CODEMAKE("TMAKE",TMAKE_OP);
CODEMAKE("CONSTR",CONSTR_OP);
CODEMAKE("FTOF",FTOF_OP);
CODEMAKE("TVADD",TVADD_OP);
CODEMAKE("TVSUB",TVSUB_OP);
CODEMAKE("TTMUL",TTMUL_OP);
CODEMAKE("TINVRT",TINVRT_OP);
CODEMAKE("DEPR",DEPR_OP); ! Added by ARG;
CODEMAKE("FMAKE",FMAKE_OP);
DTYPMAKE("GVAR",GVAL_DTYPE); ! Global. Added by RF;
DTYPMAKE("REF",REF_DTYPE);
DTYPMAKE("VAL",VAL_DTYPE);
DTYPMAKE("SVAR",SVAL_DTYPE);
DTYPMAKE("VVAR",V3ECT_DTYPE);
DTYPMAKE("TVAR",TRANS_DTYPE);
DTYPMAKE("RVAR",ROTN_DTYPE);
DTYPMAKE("FVAR",FRAME_DTYPE);
DTYPMAKE("ATOM",ATOM_DTYPE);
DTYPMAKE("EVAR",EVENT_DTYPE);
DTYPMAKE("WVAR",WORLD_DTYPE);
DTYPMAKE("ARAY",ARAY_DTYPE);
DTYPMAKE("PROC",PROC_DTYPE);
DTYPMAKE("LAB",STMLAB_DTYPE);
DTYPMAKE("OMNLAB",OMNLAB_DTYPE);
DTYPMAKE("STMLAB",STMLAB_DTYPE);
END;
REQUIRE INPINIT INITIALIZATION;
! nextline, inscan, skipblanks, scan_token;
PROCEDURE NEXTLINE;
BEGIN
WHILE INPLEV>0 DO
BEGIN
IF ¬EOF[SCNCHN[INPLEV]] THEN
BEGIN
SCNSTK[INPLEV]←SCNSTK[INPLEV]&
INPUT(SCNCHN[INPLEV],LINBRK);
RETURN;
END
ELSE
BEGIN
RELEASE(SCNCHN[INPLEV]);
INPLEV←INPLEV-1;
END;
END;
OUTSTR("*");
SCNSTK[0]←SCNSTK[0]&INCHWL&LF;
END;
STRING PROCEDURE INSCAN(INTEGER BRKTBL;REFERENCE INTEGER BC);
BEGIN
WHILE ¬LENGTH(SCNSTK[INPLEV]) DO NEXTLINE;
RETURN(SCAN(SCNSTK[INPLEV],BRKTBL,BC));
END;
INTEGER PROCEDURE SKIPBLANKS;
BEGIN
! returns the first non-"blank" character;
INTEGER C;
STRING S;
DO S←INSCAN(BLNKBRK,C) UNTIL C≠0;
RETURN(C);
END;
INTEGER PROCEDURE SCAN_TOKEN;
BEGIN
INTEGER C,IX;
C←SKIPBLANKS;
IF "A" ≤(C LAND '137)≤ "Z" ∨ C="_" ∨ C="$" THEN
BEGIN ! Modified by RF;
! an identifier;
INTEGER TYP;
SCNID←INSCAN(IDBRK,C);
SYM←CVSI(SCNID,C);
IF C THEN
RETURN(IDENT_CODE)
ELSE IF TYPEIT(SYM)≠REC_CODE THEN
RETURN(IV_CODE);
TYP ← RECTYPE(∂(SYM));
IF TYP=LOC(RESERVED_WORD) THEN
RETURN(RESERVED_WORD:RWTYPE[∂(SYM)])
ELSE IF TYP=LOC(IDENT) THEN
RETURN(IDENT_CODE)
ELSE IF TYP=LOC(VARIABLE) THEN
RETURN(VAR_CODE)
ELSE IF TYP=LOC(SVAL) ∨ TYP=LOC(V3ECT) ∨ TYP=LOC(ROTN) ∨
TYP=LOC(FRAME) ∨ TYP=LOC(TRANS) THEN
RETURN(CONST_CODE)
ELSE
RETURN(IV_CODE);
END;
IX←IF C="-" ∨ C="+" THEN 2 ELSE 1;
IF SCNSTK[INPLEV][IX FOR 1]="." THEN IX←IX+1;
IF "0"≤SCNSTK[INPLEV][IX FOR 1]≤"9" THEN
BEGIN
SCNRVAL←REALSCAN(SCNSTK[INPLEV],C);
RETURN(VAL_CODE);
END;
IF C="""" THEN
BEGIN
SCNID←NULL;
WHILE TRUE DO
BEGIN
C←LOP(SCNSTK[INPLEV]);
SCNID←SCNID&INSCAN(STRBRK,C);
IF C="""" THEN
BEGIN
IF SCNSTK[INPLEV]="""" THEN
SCNID←SCNID&LOP(SCNSTK[INPLEV])
ELSE DONE;
END
ELSE IF C=LF ∨ C=0 THEN
SCNID ← SCNID & CRLF;
END;
IF SCNID = NULL THEN SCNID ← CRLF;
RETURN(STR_CODE);
END;
C←SCNID←LOP(SCNSTK[INPLEV]);
RETURN(C);
END;
! read and fread;
INTERNAL RANY RECURSIVE PROCEDURE READ(INTEGER T(0));
BEGIN
RCELL LD;
RCELL C;
RANY V;
LABEL RESCANNIT;
RESCANNIT:
IF T=0 THEN
T←SCAN_TOKEN;
IF T≤0 THEN
CASE -T OF
BEGIN
[-IDENT_CODE] BEGIN
SYM←CVSI(SCNID,T);
IF ¬T THEN RETURN(∂(SYM));
SYM←NEW(NEW_RECORD(IDENT));
IDENT:ID[∂(SYM)]←SYM;
NEW_PNAME(SYM,SCNID);
RETURN(∂(SYM));
END;
[-RW_CODE] RETURN(∂(SYM));
[-DIR_CODE] RETURN(∂(SYM));
[-EOP_CODE] RETURN(∂(SYM));
[-DTYP_CODE] RETURN(∂(SYM));
[-VAR_CODE] RETURN(∂(SYM));
[-CONST_CODE] RETURN(∂(SYM)); ! Added by RF;
[-VAL_CODE] BEGIN
V←NEW_RECORD(SVAL);
SVAL:VAL[V]←SCNRVAL;
RETURN(V);
END;
[-STR_CODE] BEGIN
V←NEW_RECORD(STCONST);
STCONST:VAL[V]←NEW(SCNID);
RETURN(V);
END;
[-IV_CODE] BEGIN
V←NEW_RECORD(IVAR);
IVAR:IVAR[V]←SYM;
RETURN(V);
END;
[UNKN_CODE] BEGIN
USERERR(1,1,"CONFUSION IN THE SCANNER");
RETURN(NULL_RECORD);
END
END;
IF T="(" THEN
BEGIN
LD←C←NULL_RECORD;
WHILE (T←SCAN_TOKEN)≠")" DO
BEGIN
V←CONS(READ(T),NULL_RECORD);
IF LD=NULL_RECORD THEN
LD←V
ELSE
CELL:CDR[C]←V;
C←V;
END;
RETURN(LD);
END
ELSE
BEGIN
V←NEW_RECORD(CHAR_REC);
CHAR_REC:CHAR[V]←T;
RETURN(V);
END;
END;
INTERNAL RANY RECURSIVE PROCEDURE FREAD(STRING FILE_NAME);
BEGIN ! hack for linking with the parser and/or snail in rpg mode;
SCNSTK[0]←"($DSKIN """&FILE_NAME&""") ";
RETURN(READ)
END;
! get_dtype, verify_dtype, verify_1, verify_2, verify_3, dtype_check;
FORWARD RPTR(VARIABLE) PROCEDURE VTRY
(RANY V;INTEGER DTYP (INVALID_DTYPE));
! On the next page;
INTEGER PROCEDURE GET_DTYPE(RANY X; INTEGER DTYP (INVALID_DTYPE));
BEGIN
! Modified by RF. If X is a variable, VTRY is called
on it with DTYP. This helps in properly declaring
undeclared variables which are first used in expressions;
INTEGER I;
I←RECTYPE(X);
RETURN(IF I=LOC(EXPRN) THEN EXPRN:DATATYPE[X]
ELSE IF I=LOC(LBLVAR) THEN LBLVAR:DATATYPE[X]
ELSE IF I=LOC(CALCULATOR) THEN GET_DTYPE(CALCULATOR:FORM[X])
ELSE IF I=LOC(VARIABLE) THEN VARIABLE:DATATYPE[VTRY(X,DTYP)]
ELSE IF I=LOC(ARRAYDEF) THEN ARRAYDEF:DATATYPE[X]
ELSE IF I=LOC(SVAL) THEN SVAL_DTYPE
ELSE IF I=LOC(V3ECT) THEN V3ECT_DTYPE
ELSE IF I=LOC(ROTN) THEN ROTN_DTYPE
ELSE IF I=LOC(TRANS) THEN TRANS_DTYPE
ELSE IF I=LOC(FRAME) THEN FRAME_DTYPE
ELSE INVALID_DTYPE);
END;
PROCEDURE VERIFY_DTYPE(RPTR(EXPRN,VARIABLE,VALU$) X;INTEGER T);
BEGIN
INTEGER TT;
TT←GET_DTYPE(X,T);
IF TT≠T THEN
BEGIN
IF ¬(TT=FRAME_DTYPE∧T=TRANS_DTYPE) THEN
BEGIN
ALPRIN(X);
USERERR(1,1,"PARSER: wrong expression data type");
END;
END;
END;
PROCEDURE VERIFY_1(RCELL C;INTEGER T);
BEGIN
IF C=NULL THEN
BEGIN
USERERR(1,1,"NOT ENOUGH ARGS");
END
ELSE
VERIFY_DTYPE(CELL:CAR[C],T);
END;
PROCEDURE VERIFY_2(RCELL C;INTEGER T1,T2);
BEGIN
IF CL_LEN(C)<2 THEN
BEGIN
USERERR(1,1,"NOT ENOUGH ARGS");
END
ELSE
BEGIN
VERIFY_DTYPE(CELL:CAR[C],T1);
VERIFY_DTYPE(CELL:CAR[CELL:CDR[C]],T2);
END;
END;
PROCEDURE VERIFY_3(RCELL C;INTEGER T1,T2,T3);
BEGIN
IF C=NULL THEN
USERERR(1,1,"NOT ENOUGH ARGS")
ELSE
BEGIN
VERIFY_DTYPE(CELL:CAR[C],T1);
VERIFY_2(CELL:CDR[C],T2,T3);
END;
END;
PROCEDURE DTYPE_CHECK(RPTR(EXPRN) E);
BEGIN
INTEGER OP,NARGS;
RCELL EARGS,C,T;
RANY P;
OP←EXPRN:OP[E];
EARGS←EXPRN:ARGS[E];
EXPRN:DATATYPE[E]←
IF OP=AREF_OP THEN ARRAYDEF:DATATYPE[P←LLOP(EARGS)]
ELSE IF OP=CALL_OP THEN PROCDEF:DATATYPE[P←LLOP(EARGS)]
ELSE IF MIN_SVAL_OP≤OP≤MAX_SVAL_OP THEN SVAL_DTYPE
ELSE IF MIN_V3ECT_OP≤OP≤MAX_V3ECT_OP THEN V3ECT_DTYPE
ELSE IF MIN_ROTN_OP≤OP≤MAX_ROTN_OP THEN ROTN_DTYPE
ELSE IF MIN_TRANS_OP≤OP≤MAX_TRANS_OP THEN TRANS_DTYPE
ELSE IF MIN_FRAME_OP≤OP≤MAX_FRAME_OP THEN FRAME_DTYPE
ELSE INVALID_DTYPE;
CASE OP OF
BEGIN
[SCALRD_OP] [QUERY_OP] ; ! don't have any args;
[SABS_OP] VERIFY_1(EARGS,SVAL_DTYPE);
[SADD_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SSUB_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SNEG_OP] VERIFY_1(EARGS,SVAL_DTYPE);
[SMUL_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SDIV_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SEXP_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[MAX_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[MIN_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[INT_OP] VERIFY_1(EARGS,SVAL_DTYPE);
[DIV_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[MOD_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SLT_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SGT_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SEQ_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SLE_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SGE_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[SNE_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[AND_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[OR_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[NOT_OP] VERIFY_1(EARGS,SVAL_DTYPE);
[XOR_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[EQV_OP] VERIFY_2(EARGS,SVAL_DTYPE,SVAL_DTYPE);
[VMAGN_OP] VERIFY_1(EARGS,V3ECT_DTYPE);
[VDOT_OP] VERIFY_2(EARGS,V3ECT_DTYPE,V3ECT_DTYPE);
[SVMUL_OP] VERIFY_2(EARGS,SVAL_DTYPE,V3ECT_DTYPE);
[VSDIV_OP] VERIFY_2(EARGS,V3ECT_DTYPE,SVAL_DTYPE);
[VMAKE_OP] VERIFY_3(EARGS,SVAL_DTYPE,SVAL_DTYPE,SVAL_DTYPE);
[VADD_OP] VERIFY_2(EARGS,V3ECT_DTYPE,V3ECT_DTYPE);
[VSUB_OP] VERIFY_2(EARGS,V3ECT_DTYPE,V3ECT_DTYPE);
[VCROSS_OP] VERIFY_2(EARGS,V3ECT_DTYPE,V3ECT_DTYPE);
[TVMUL_OP] VERIFY_2(EARGS,TRANS_DTYPE,V3ECT_DTYPE);
[TVADD_OP] VERIFY_2(EARGS,TRANS_DTYPE,V3ECT_DTYPE);
[TVSUB_OP] VERIFY_2(EARGS,TRANS_DTYPE,V3ECT_DTYPE);
[RVMUL_OP] VERIFY_2(EARGS,ROTN_DTYPE,V3ECT_DTYPE);
[RMAGN_OP] VERIFY_1(EARGS,ROTN_DTYPE);
[AXIS_OP] VERIFY_1(EARGS,ROTN_DTYPE);
[POS_OP] VERIFY_1(EARGS,TRANS_DTYPE);
[ORIENT_OP] VERIFY_1(EARGS,TRANS_DTYPE);
[RRMUL_OP] VERIFY_2(EARGS,ROTN_DTYPE,ROTN_DTYPE);
[UVECT_OP] VERIFY_1(EARGS,V3ECT_DTYPE);
[AXW_ROTN_OP] VERIFY_2(EARGS,V3ECT_DTYPE,SVAL_DTYPE);
[FTOF_OP] VERIFY_2(EARGS,FRAME_DTYPE,FRAME_DTYPE);
[TMAKE_OP] VERIFY_2(EARGS,ROTN_DTYPE,V3ECT_DTYPE);
[CONSTR_OP] VERIFY_3(EARGS,V3ECT_DTYPE,V3ECT_DTYPE,V3ECT_DTYPE);
[TTMUL_OP] VERIFY_2(EARGS,TRANS_DTYPE,TRANS_DTYPE);
[TINVRT_OP] VERIFY_1(EARGS,TRANS_DTYPE);
[DEPR_OP] VERIFY_1(EARGS,FRAME_DTYPE);
[FMAKE_OP] VERIFY_2(EARGS,ROTN_DTYPE,V3ECT_DTYPE);
[SSBRTN_OP] CASE (OP ← SVAL:VAL[CELL:CAR[EARGS]]) OF
BEGIN
[SQRT_OP] [SIN_OP] [COS_OP]
[ASIN_OP] [ACOS_OP]
[LOG_OP] [EXP_OP] VERIFY_1(CELL:CDR[EARGS],SVAL_DTYPE);
[ATAN2_OP] VERIFY_2(CELL:CDR[EARGS],SVAL_DTYPE,SVAL_DTYPE)
END;
[CALL_OP] BEGIN "procedure call"
NARGS ← 0;
T ← PROCDEF:ARGS[P];
WHILE EARGS ≠ RNULL DO
BEGIN "count args"
NARGS ← NARGS + 1;
VERIFY_DTYPE((C←LLOP(EARGS)),VARIABLE:DATATYPE[LLOP(T)])
END;
IF NARGS < PROCDEF:NUMARGS[P] THEN
BEGIN "not enough args"
USERERR(1,1,"PARSER: NOT ENOUGH ARGMENTS FOR PROCEDURE");
IF C = RNULL THEN C ← CELL:CDR[EXPRN:ARGS[E]];
WHILE NARGS < PROCDEF:NUMARGS[P] DO
BEGIN
NARGS ← NARGS + 1;
CASE VARIABLE:DATATYPE[LLOP(T)] OF
BEGIN
[SVAL_DTYPE] C ← CELL:CDR[C] ← CONS(FALSEV,RNULL);
[V3ECT_DTYPE] C ← CELL:CDR[C] ← CONS(NILVECT,RNULL);
[ROTN_DTYPE] C ← CELL:CDR[C] ← CONS(NILROTN,RNULL);
[TRANS_DTYPE] C ← CELL:CDR[C] ← CONS(NILTRANS,RNULL);
[FRAME_DTYPE] C ← CELL:CDR[C] ← CONS(NILDEPROACH,RNULL);
ELSE C ← CELL:CDR[C] ← CONS(FALSEV,RNULL)
END
END
END "not enough args"
END "procedure call";
[AREF_OP] BEGIN "array reference"
NARGS ← 0;
WHILE EARGS ≠ RNULL DO
BEGIN "count args"
NARGS ← NARGS + 1;
VERIFY_DTYPE((C←LLOP(EARGS)),SVAL_DTYPE)
END;
IF NARGS < ARRAYDEF:NUMDIMS[P] THEN
BEGIN "not enough subscripts"
USERERR(1,1,"PARSER: NOT ENOUGH SUBSCRIPTS");
IF C = RNULL THEN C ← CELL:CDR[EXPRN:ARGS[E]];
WHILE NARGS < ARRAYDEF:NUMDIMS[P] DO
BEGIN
NARGS ← NARGS + 1;
C ← CELL:CDR[C]
← CONS(NEW_SVAL(ARRAYDEF:BDVALS[P][NARGS,0]),RNULL)
END
END "not enough subscripts"
END "array reference";
[LAST_OP] END;
END;
! asgbki, identlookup, ensym, vblmake, vtry, mkblkbody;
RPTR(BLOCK) GVLBLK; ! Current block being gobbled;
RPTR(BLOCK) IDBLK; ! Block ident of last thing from identlookup;
RPTR(CMON) CCMON; ! Current cmon being gobbled (if any);
INTEGER ALSOTYPE; ! Used to tell the type of NEWV and OLDV in changers;
INTEGER UNIQUENO;INITIALIZE(UNIQUENO←0);
INTEGER BLKNO;INITIALIZE(BLKNO←0);
PROCEDURE ASGBKI(RPTR(BLOCK) B);
BEGIN
ITEMVAR DUMMY;
INTEGER FLAG;
DO BEGIN
BLKNO←BLKNO+1;
DUMMY←CVSI("$B"&CVS(BLKNO),FLAG);
IF FLAG THEN
NEW_PNAME(BLOCK:BLID[B]←NEW(B),"$B"&CVS(BLKNO));
END UNTIL FLAG;
END;
RANY PROCEDURE IDENTLOOKUP(RPTR(IDENT) V);
BEGIN
RANY ITEMVAR VID;
IF RECTYPE(V)≠LOC(IDENT) THEN
BEGIN
USERERR(1,1,"DRYROT IN IDENTLOOKUP");
RETURN(RNULL);
END;
IDBLK←GVLBLK;
WHILE IDBLK≠NULL_RECORD DO
BEGIN
IF BLOCK:BLID[IDBLK]⊗IDENT:ID[V]≡BIND VID THEN
RETURN(∂(VID));
IDBLK←BLOCK:PARENT[IDBLK];
END;
RETURN(V);
END;
PROCEDURE ENSYM(RPTR(IDENT) ID;RANY V;REFERENCE RANY ITEMVAR IDSLOT);
BEGIN
STRING IDSTR;
IF IDSLOT=ANY THEN
IDSLOT←NEW(V);
IF RECTYPE(ID)≠LOC(IDENT) THEN
BEGIN
PRINT(CRLF&"****");RECPRN(ID);PRINT(CRLF);
USERERR(1,1,"NEED AN ID HERE");
END;
IDENTLOOKUP(ID);
IDSTR←ITMNAM(BLOCK:BLID[GVLBLK])&"."&ITMNAM(IDENT:ID[ID]);
IF IDBLK=GVLBLK THEN
BEGIN
USERERR(1,1,"WARNING DUP ID: "&IDSTR);
IDSTR←IDSTR&"."&CVS(UNIQUENO←UNIQUENO+1);
END;
NEW_PNAME(IDSLOT,IDSTR);
MAKE BLOCK:BLID[GVLBLK]⊗IDENT:ID[ID]≡IDSLOT;
END;
RPTR(VARIABLE,LBLVAR) PROCEDURE VBLMAKE(RPTR(IDENT) V;INTEGER DTYP);
BEGIN
RPTR(VARIABLE,LBLVAR) ITEMVAR VVID;
RPTR(VARIABLE,LBLVAR) VV;
IF DTYP=STMLAB_DTYPE∨DTYP=OMNLAB_DTYPE THEN
VV←NEW_LBL(VVID←NEW(RNULL),DTYP,GVLBLK)
ELSE
VV←NEW_VAR(VVID←NEW(RNULL),DTYP,GVLBLK);
∂(VVID)←VV;
ENSYM(V,VV,VARIABLE:NAME[VV]);
RETURN(VV);
END;
RPTR(VARIABLE,LBLVAR) PROCEDURE VTRY(RANY V; INTEGER DTYP (INVALID_DTYPE));
BEGIN "vtry"
! Modified by RF. Returns V. If it was a declared variable, it
checks its type to make sure it is DTYP (unless DTYP was not
specified). If it was not declared, VTRY declares it with DTYP.
Complains if V is not a declared variable or an IDENT.;
RPTR(VARIABLE) VAR;
INTEGER DUMMY;
INTEGER RT,VDT;
RT←RECTYPE(V);
IF RT=LOC(IDENT) THEN
BEGIN
V←IDENTLOOKUP(V);
RT←RECTYPE(V);
END;
IF RT = LOC(IDENT) THEN
BEGIN ! May be declared;
USERERR(1,1,"VTRY: Will define " & CVIS(IDENT:ID[V],DUMMY));
VAR←VBLMAKE(V,DTYP);
END
ELSE IF RT = LOC(ARRAYDEF) THEN RETURN(V)
ELSE IF RT = LOC(PROCDEF) THEN RETURN(V)
ELSE IF RT = LOC(VARIABLE)
THEN BEGIN ! Just need to check the type;
VAR←V;
END
ELSE IF RT = LOC(LBLVAR) THEN
BEGIN
RETURN(LBLVAR:SEMANTICS[V]);
END
ELSE BEGIN
USERERR(1,1,"VTRY: Bad argument");
RETURN(V);
END;
VDT←VARIABLE:DATATYPE[VAR];
IF (DTYP ≠ INVALID_DTYPE) ∧ (VDT ≠ DTYP) THEN
BEGIN ! May want to put right type in;
IF VDT = INVALID_DTYPE THEN VARIABLE:DATATYPE[VAR] ← DTYP
ELSE IF VDT = FRAME_DTYPE ∧ DTYP=TRANS_DTYPE THEN BEGIN ! OK; END
ELSE USERERR(1,1,"VTRY: " & CVIS(VARIABLE:NAME[V],DUMMY) &
" has wrong type");
END;
RETURN(VAR);
END "vtry";
PROCEDURE MKBLKBODY(REFERENCE RCELL C);
BEGIN
RPTR(BLKOP) BEN,BEX;
BEN←NEW_RECORD(BLKOP);BLKOP:OP[BEN]←ENTERBLOCK;
BEX←NEW_RECORD(BLKOP);BLKOP:OP[BEX]←LEAVEBLOCK;
C←APPEND(C,CONS(STMAKE(BEX),NULL_RECORD));
CONSON(STMAKE(BEN),C);
END;
! grovel (lllop, gllop, widget, stgrovel, lgrovel, constelim);
INTERNAL RANY RECPROC GROVEL(RANY SE);
BEGIN
RCELL C;
RANY KIND,V;
INTEGER IX;
OWN INTEGER GLBFLG, REFFLG, VALFLG; ! Used for global, reference & value decs;
LABEL REGROVEL;
RANY PROCEDURE LLLOP;
RETURN(LLOP(C));
RANY PROCEDURE GLLOP;
IF C ≠ RNULL THEN RETURN(GROVEL(LLLOP)) ELSE RETURN(RNULL);
ITEMVAR PROCEDURE WIDGET; ! world id get;
BEGIN
RANY IC;
IF C=NULL_RECORD THEN RETURN(ANY);
IC←VTRY(LLLOP,WORLD_DTYPE);
IF RECTYPE(IC)≠LOC(VARIABLE) THEN RETURN(ANY);
IF VARIABLE:DATATYPE[IC]≠WORLD_DTYPE THEN
BEGIN
PRINT(CRLF&"****");ALPRIN(IC);PRINT(CRLF);
USERERR(1,1,"MUST HAVE A WORLD VARIABLE");
RETURN(ANY);
END;
RETURN(VARIABLE:NAME[IC]);
END;
RSTMNT PROCEDURE STGROVEL;
BEGIN
IF C≠NULL_RECORD THEN
BEGIN
RANY S;
S ← GLLOP;
IF RECTYPE(S)=LOC(EXPRN) ∧ EXPRN:OP[S]=CALL_OP THEN
S←STMAKE(S);
RETURN(CHKREC(S,LOC(STMNT)))
END
ELSE
RETURN(STMAKE(NULL_RECORD));
! RHT: 3-23-76 Used to return NULL_RECORD;
END;
RCELL RECPROC LGROVEL(RCELL C);
BEGIN ! Grovels down a list;
RCELL C1,C2,C3;
C1←C3←NULL_RECORD;
WHILE C≠NULL_RECORD DO
BEGIN
C2 ← GROVEL(CELL:CAR[C]);
IF C2 ≠ RNULL
THEN BEGIN ! This case added by RF;
C2 ← CONS(C2,RNULL);
IF C1=NULL_RECORD
THEN C1←C3←C2
ELSE CELL:CDR[C1] ← C2;
C1←C2;
END;
C←CELL:CDR[C];
END;
RETURN(C3);
END;
RPTR (VALU$,EXPRN) PROCEDURE CONSTELIM (RPTR(EXPRN) EX);
BEGIN "constelim" ! Coded by RF. Takes the expression EX and
replaces it with a simpler one if possible. At the moment, only
checks one level deep, since it is called repeatedly at each level.
It should be simple to make it recursive;
INTEGER TYP, FLAG;
ITEMVAR DUMMY;
RANY PTR;
IF RECTYPE(EX) ≠ LOC(EXPRN)
THEN BEGIN
PRINT(CRLF&"****");ALPRIN(EX);
USERERR(1,1,"CONSTELIM: Not an expression");
RETURN(EX);
END;
! Make sure the operands are all constants;
PTR ← EXPRN:ARGS[EX];
FLAG ← FALSE;
WHILE PTR ≠ RNULL DO
BEGIN "cloop"
TYP ← RECTYPE(CELL:CAR[PTR]);
IF FLAG ← (TYP=LOC(SVAL) ∨ TYP=LOC(V3ECT) ∨ TYP=LOC(ROTN) ∨ TYP=LOC(TRANS)
∨ TYP=LOC(FRAME))
THEN PTR ← CELL:CDR[PTR]
ELSE DONE "cloop";
END "cloop";
IF ¬FLAG THEN RETURN(EX) ! Can't do anything;
ELSE RETURN(EVALEXPR(EX,DUMMY));
END;
! grovel: REGROVEL: DIR, EOP, DTYP;
REGROVEL:
IF RECTYPE(SE)≠LOC(CELL) THEN
BEGIN ! Modified by RF so that VTRY includes CHKREC;
! **** I don't see any call to CHKREC in VTRY ****;
IF RECTYPE(SE) = LOC(IDENT)
THEN RETURN(VTRY(SE))
ELSE RETURN(SE);
END;
KIND←CELL:CAR[SE];
C←CELL:CDR[SE];
IX←RECTYPE(KIND);
IF IX=LOC(IDENT) THEN
BEGIN
KIND←IDENTLOOKUP(KIND);
IX←RECTYPE(KIND);
END;
IF IX=LOC(LBLVAR) THEN
BEGIN
V←GROVEL(C);
IX←RECTYPE(V);
IF LBLVAR:SEMANTICS[KIND]≠NULL_RECORD THEN
BEGIN
PRINT(CRLF&"****");ALPRIN(KIND);
USERERR(1,1,"DUPLICATE USE OF LABEL")
END
ELSE
ASGLBL(KIND,V);
RETURN(V);
END
ELSE IF IX≠LOC(RESERVED_WORD) THEN
RETURN(LGROVEL(SE));
IX←RESERVED_WORD:RWTYPE[KIND];
CASE -IX OF
BEGIN
[-DIR_CODE] BEGIN
CASE RESERVED_WORD:CODE[KIND] OF
BEGIN
[DSKIN_OP] BEGIN
V←GLLOP;
IF RECTYPE(V)=LOC(STCONST) THEN
BEGIN
INTEGER CH;
CH←READFILE(∂(STCONST:VAL[V]));
IF CH<0 THEN
RETURN(NULL_RECORD);
INPLEV←INPLEV+1;
SCNCHN[INPLEV]←CH;
SCNSTK[INPLEV]←INPUT(SCNCHN[INPLEV],LINBRK);
IF EQU(SCNSTK[INPLEV][1 FOR 9],"COMMENT ⊗") THEN
BEGIN "skip over E directory page"
DO SCNSTK[INPLEV]←INPUT(SCNCHN[INPLEV],LINBRK)
UNTIL EQU(SCNSTK[INPLEV][1 FOR 3],"C⊗;")
∨ EOF[SCNCHN[INPLEV]];
IF EOF[SCNCHN[INPLEV]] THEN
USERERR(1,1,"DIRECTORY END NOT DETECTED");
SCNSTK[INPLEV]←NULL
END;
SE←READ;
GO TO REGROVEL;
END;
END;
[INIOUT_OP] BEGIN
INITIALIZE_OUTPUT;
RETURN(NULL_RECORD);
END;
[0] END;
END;
[-EOP_CODE] BEGIN "EOPCODE"
V←NEW_RECORD(EXPRN);
EXPRN:OP[V]←RESERVED_WORD:CODE[KIND];
EXPRN:ARGS[V]←LGROVEL(C);
DTYPE_CHECK(V);
V ← CONSTELIM(V);
RETURN(V);
END;
! grovel: DTYP: ARRAY, PROCEDURE;
[-DTYP_CODE] BEGIN "VBL"
IF RESERVED_WORD:CODE[KIND] = GVAL_DTYPE THEN
BEGIN "globdec"
GLBFLG ← TRUE;
GROVEL(C);
GLBFLG ← FALSE;
END
ELSE IF RESERVED_WORD:CODE[KIND] = REF_DTYPE THEN
BEGIN "refdec"
REFFLG ← TRUE;
GROVEL(C);
REFFLG ← FALSE;
END
ELSE IF RESERVED_WORD:CODE[KIND] = VAL_DTYPE THEN
BEGIN "valdec"
VALFLG ← TRUE;
GROVEL(C);
VALFLG ← FALSE;
END
ELSE IF RESERVED_WORD:CODE[KIND] = ARAY_DTYPE THEN
BEGIN "array dec"
INTEGER DT,NDIMS,I,J;
RPTR(ARRAYDEF) ARAY;
RCELL BNDS;
DT ← RESERVED_WORD:CODE[LLLOP];
WHILE C ≠ RNULL DO
BEGIN
ARAY ← NEW_RECORD(ARRAYDEF);
ARRAYDEF:DATATYPE[ARAY] ← DT;
ARRAYDEF:NAME[ARAY] ← NEW(ARAY);
ARRAYDEF:BLK[ARAY] ← GVLBLK;
CONSON(ARAY,BLOCK:ARAYS[GVLBLK]);
V ← LLLOP; ! fetch array name;
ENSYM(V,ARAY,ARRAYDEF:NAME[ARAY]);
BNDS ← CELL:CAR[C];
NDIMS ← 0;
WHILE BNDS ≠ RNULL DO
BEGIN
NDIMS ← NDIMS + 1;
BNDS ← CELL:CDR[CELL:CDR[BNDS]]
END;
ARRAYDEF:NUMDIMS[ARAY] ← NDIMS;
IF NDIMS THEN
BEGIN ! this is so procedure arguments can be arrays;
REQUIRE "<><>" DELIMITERS;
NewArray(REXPR,ARRAYDEF:BOUNDS[ARAY],[1:NDIMS,0:3]);
NewArray(INTEGER,ARRAYDEF:BDVALS[ARAY],[1:NDIMS,0:2]);
REQUIRE UNSTACK_DELIMITERS;
END;
BNDS ← LLLOP;
FOR I ← 1 TIL NDIMS DO
FOR J ← 0 TIL 1 DO
BEGIN
ARRAYDEF:BOUNDS[ARAY][I,J] ← GROVEL(LLOP(BNDS));
IF RECTYPE(ARRAYDEF:BOUNDS[ARAY][I,J]) = LOC(EXPRN) THEN
ARRAYDEF:BOUNDS[ARAY][I,J+2] ←
NEW_VAR(NEW(RNULL),SVAL_DTYPE,BLOCK:PARENT[GVLBLK])
END
END
END "array dec"
ELSE IF RESERVED_WORD:CODE[KIND] = PROC_DTYPE THEN
BEGIN "procedure dec"
INTEGER NARGS;
RPTR(BLOCK) SAVEBLK,T;
RANY P,N;
RCELL ARGLIST,L;
V ← NEW_RECORD(PROCDEF);
PROCDEF:DATATYPE[V] ← (IF RECTYPE(CELL:CAR[C]) =
LOC(RESERVED_WORD) THEN RESERVED_WORD:CODE[LLLOP] ELSE 0);
CONSON(V,BLOCK:PROCS[GVLBLK]);
PROCDEF:NAME[V] ← NEW(V);
P ← LLLOP; ! get procedure's name;
ENSYM(P,V,PROCDEF:NAME[V]);
T ← NEW_RECORD(BLOCK);
PROCDEF:BODY[V] ← STMAKE(T);
ASGBKI(T);
BLOCK:PARENT[T] ← SAVEBLK ← GVLBLK;
GVLBLK ← T;
L ← RNULL;
ARGLIST ← CELL:CAR[C]; ! save pointer to arg list;
LGROVEL(LLLOP); ! parse the arg list defining variables;
WHILE ARGLIST ≠ RNULL DO
BEGIN
P←LLOP(ARGLIST);
WHILE P ≠ RNULL DO
IF RECTYPE((N←LLOP(P))) = LOC(IDENT) THEN
BEGIN
NARGS ← NARGS + 1;
N ← CONS(IDENTLOOKUP(N),RNULL);
IF L = RNULL THEN PROCDEF:ARGS[V] ← N
ELSE CELL:CDR[L] ← N;
L ← N
END
END;
PROCDEF:NUMARGS[V] ← NARGS;
BLOCK:CODE[T] ← LGROVEL(C); ! parse procedure body;
IF BLOCK:VARS[T] ≠ RNULL ∨ BLOCK:ARAYS[T] ≠ RNULL THEN
MKBLKBODY(BLOCK:CODE[T]); ! if procedure has arguments;
GVLBLK ← SAVEBLK
END "procedure dec"
ELSE WHILE C≠NULL_RECORD DO
BEGIN
V←LLLOP; ! Modified by RF;
! Further modified by RHT;
IF RECTYPE(V)≠LOC(IDENT) THEN
BEGIN
PRINT(CRLF&"****");RECPRN(V);PRINT(CRLF);
USERERR(1,1,"FUNNY THING FOR VARIABLE");
CONTINUE;
END;
V ← VBLMAKE(V,RESERVED_WORD:CODE[KIND]);
IX ← IF GLBFLG THEN GLBAL ELSE IF REFFLG THEN REFARG
ELSE IF VALFLG THEN VALARG ELSE 0;
VARIABLE:ATTRIBUTES[V] ← VARIABLE:ATTRIBUTES[V] LOR IX;
END;
RETURN(RNULL); ! Used to return V. Changed by RF;
END;
! grovel: main body: PROG,BLOCK,COBLOCK,FORR,WHIL,IFF,PAUSE,ABORT,CIF,COMMNT;
[-RW_CODE] BEGIN "RWCODE"
CASE RESERVED_WORD:CODE[KIND] OF
BEGIN
[PROGTYPE] BEGIN
V←NEW_RECORD(PROG);
PROG:CODE[V]←STGROVEL;
RETURN(STMAKE(V));
END;
[BLOCKTYPE] BEGIN ! Modified by RF;
RPTR(BLOCK) SAVEBLK;
V←NEW_RECORD(BLOCK);
ASGBKI(V);
SAVEBLK←GVLBLK;
BLOCK:PARENT[V]←SAVEBLK;
GVLBLK←V;
BLOCK:CODE[V] ← LGROVEL(C);
IF BLOCK:VARS[V] ≠ RNULL ∨ BLOCK:ARAYS[V] ≠ RNULL THEN
MKBLKBODY(BLOCK:CODE[V]); ! if local variables;
GVLBLK←SAVEBLK;
RETURN(STMAKE(V));
END;
[COBLOCKTYPE] BEGIN
V←NEW_RECORD(COBLOCK);
COBLOCK:CODE[V]←LGROVEL(C);
RETURN(STMAKE(V));
END;
[FORRTYPE] BEGIN
V←NEW_RECORD(FORR);
FORR:CONVAR[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,SVAL_DTYPE) ELSE GLLOP);
FORR:INITIAL[V]←GLLOP;
FORR:STEP[V]←GLLOP;
FORR:FINAL[V]←GLLOP;
FORR:BODY[V]←STGROVEL;
RETURN(STMAKE(V));
END;
[WHILTYPE] BEGIN
V←NEW_RECORD(WHIL);
WHIL:COND[V]←GLLOP;
WHIL:BODY[V]←STGROVEL;
RETURN(STMAKE(V));
END;
[UNTLTYPE] BEGIN
V←NEW_RECORD(UNTL);
UNTL:BODY[V]←STGROVEL;
UNTL:COND[V]←GLLOP;
RETURN(STMAKE(V));
END;
[IFFTYPE] BEGIN
V←NEW_RECORD(IFF);
IFF:COND[V]←GLLOP;
IFF:THN[V]←STGROVEL;
IFF:ELS[V]←STGROVEL;
RETURN(STMAKE(V));
END;
[PAUSETYPE] BEGIN
V←NEW_RECORD(PAUSE);
PAUSE:VAL[V]←GLLOP;
RETURN(STMAKE(V));
END;
[PROMPTTYPE] BEGIN
V←NEW_RECORD(PROMPT);
PROMPT:VAL[V]←LGROVEL(C); ! Gets a list of print items;
RETURN(STMAKE(V));
END;
[ABORTTYPE] BEGIN
V←NEW_RECORD(ABORT);
ABORT:VAL[V]←LGROVEL(C); ! Gets a list of print items;
RETURN(STMAKE(V));
END;
[CIFTYPE] BEGIN
V←NEW_RECORD(CIF);
CIF:COND[V]←GLLOP;
CIF:THN[V]←STGROVEL;
CIF:ELS[V]←STGROVEL;
RETURN(STMAKE(V));
END;
[COMMNTTYPE] BEGIN ! Coded by RF;
V ← NEW_RECORD(COMMNT);
! COMMNT:HESAYS[V] ← LGROVEL(C);
! You don't really want to keep that junk;
RETURN(STMAKE(V));
END;
! grovel: main body: CASE, RETURN;
[KASETYPE] BEGIN
REQUIRE "<><>" DELIMITERS;
RANY F;
RCELL T,B;
INTEGER S,I,N,J;
V ← NEW_RECORD(KASE);
S ← I ← N ← 0;
KASE:INDEX[V] ← GLLOP;
IF RECTYPE(CELL:CAR[C]) = LOC(CELL) THEN
BEGIN "regular case statement"
T ← C;
WHILE T ≠ RNULL DO ! count the statements;
BEGIN LLOP(T); N ← N +1 END;
KASE:RANGE[V] ← N;
NewArray(INTEGER,KASE:LABS[V],[0:N,0:1]);
ARRCLR(KASE:LABS[V],N);
FOR I ← 0 TIL N-1 DO
IF (F←LLLOP) = RNULL THEN KASE:LABS[V][I,0] ← N ELSE
BEGIN
KASE:LABS[V][I,0] ← S;
S ← S + 1;
F ← GROVEL(F);
IF RECTYPE(F)=LOC(EXPRN) ∧ EXPRN:OP[F]=CALL_OP THEN
F←STMAKE(F);
F ← CONS(F,RNULL);
IF T = RNULL THEN KASE:STMNTS[V] ← F
ELSE CELL:CDR[T] ← F;
T ← F
END
END "regular case statement"
ELSE
BEGIN "numbered case statement"
T ← C;
WHILE T ≠ RNULL DO ! establish the range of the index;
IF RECTYPE(F←LLOP(T)) = LOC(SVAL) THEN
N ← N MAX (I←SVAL:VAL[F]);
KASE:RANGE[V] ← N ← N + 1;
NewArray(INTEGER,KASE:LABS[V],[0:N,0:1]);
ARRCLR(KASE:LABS[V],N);
B ← C; I ← 0;
WHILE C ≠ RNULL DO
IF (F←LLLOP) = RNULL THEN BEGIN "whoops"
WHILE B≠C DO IF RECTYPE(F←LLOP(B))=LOC(SVAL) THEN
KASE:LABS[V][SVAL:VAL[F],0] ← N END "whoops"
ELSE IF RECTYPE(F) = LOC(SVAL) THEN
IF SVAL:VAL[F] ≥ 0 THEN
KASE:LABS[V][SVAL:VAL[F],0] ← S
ELSE
BEGIN
FOR J ← 0 TIL N DO
IF KASE:LABS[V][J,0] = N THEN
KASE:LABS[V][J,0] ← S;
KASE:RANGE[V] ← - KASE:RANGE[V]
END
ELSE
BEGIN
B ← C; S ← S + 1;
F ← GROVEL(F);
IF RECTYPE(F)=LOC(EXPRN) ∧ EXPRN:OP[F]=CALL_OP THEN
F←STMAKE(F);
F ← CONS(F,RNULL);
IF T = RNULL THEN KASE:STMNTS[V] ← F
ELSE CELL:CDR[T] ← F;
T ← F
END
END "numbered case statement";
KASE:NSTMNTS[V] ← S;
IF KASE:RANGE[V] ≥ 0 THEN KASE:LABS[V][N,0] ← S;
RETURN(STMAKE(V));
REQUIRE UNSTACK_DELIMITERS;
END;
[RETRNTYPE] BEGIN
V ← NEW_RECORD(RETRN);
RETRN:VAL[V] ← GLLOP;
RETURN(STMAKE(V))
END;
! grovel: main body: NOMV, BINDV, DBD, NW, PVL, ASSERT, DENY, AFACT, SFACT;
[NOMVTYPE] BEGIN
V←NEW_RECORD(NOMV);
NOMV:E[V]←GLLOP;
NOMV:WLD[V]←WIDGET;
RETURN(V);
END;
[BINDVTYPE] BEGIN
V←NEW_RECORD(BINDV);
BINDV:VAR[V]←GLLOP;
RETURN(V);
END;
[DBDTYPE] BEGIN
V←NEW_RECORD(DBD);
DBD:WLD[V]←WIDGET;
RETURN(V);
END;
[NOTETYPE] BEGIN
V←NEW_RECORD(NOTE);
NOTE:HESAYS[V]←GLLOP; ! Better be a string constant;
RETURN(V);
END;
[NOTE1TYPE] BEGIN
V←NEW_RECORD(NOTE1);
NOTE1:HESAYS[V]←GLLOP; ! Better be a string constant;
RETURN(V);
END;
[NOTE2TYPE] BEGIN
V←NEW_RECORD(NOTE2);
NOTE2:HESAYS[V]←GLLOP; ! Better be a string constant;
RETURN(V);
END;
[NWTYPE] BEGIN ! Brave new world, that has such creatures;
V←NEW_RECORD(NW);
NW:WLD[V]←WIDGET;
RETURN(STMAKE(V));
END;
[PVLTYPE] BEGIN
V←NEW_RECORD(PVL);
PVL:VL[V]←LGROVEL(C);
RETURN(V);
END;
[PASTYPE] BEGIN ! Add by arg;
RPTR(AFACT) VV;
VV←NEW_RECORD(AFACT);
AFACT:LEFT[VV]←GLLOP;
AFACT:RIGHT[VV]←GLLOP; ! Note: afact:reln[vv]=0 ≡ "=";
V←NEW_RECORD(ASSERT);
ASSERT:FACT[V]←VV;
ASSERT:WLD[V]←ANY;
RETURN(STMAKE(V));
END;
[ASSERTTYPE] BEGIN
V←NEW_RECORD(ASSERT);
ASSERT:FACT[V]←GLLOP;
ASSERT:WLD[V]←WIDGET;
RETURN(STMAKE(V));
END;
[DENYTYPE] BEGIN
V←NEW_RECORD(DENY);
DENY:FACT[V]←GLLOP;
DENY:WLD[V]←WIDGET;
RETURN(STMAKE(V));
END;
[AFACTTYPE] BEGIN
V←NEW_RECORD(AFACT);
AFACT:LEFT[V]←GLLOP;
IX←CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
AFACT:RELN[V]←STINDX("<≤=≥>",IX)-3;
AFACT:RIGHT[V]←GLLOP;
RETURN(V);
END;
[SFACTTYPE] BEGIN
V←NEW_RECORD(SFACT);
SFACT:PATT[V]←LGROVEL(C);
RETURN(V);
END;
! grovel: main body: AFFIX, UNFIX, GASSIGN, CALCULATOR, CHANGER, ALSODO, SPECVAL;
[AFFIXTYPE] BEGIN
RPTR(VARIABLE) VAR;
V←NEW_RECORD(AFFIX);
AFFIX:FRAME1[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,FRAME_DTYPE) ELSE GLLOP);
AFFIX:FRAME2[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,FRAME_DTYPE) ELSE GLLOP);
AFFIX:BYVAR[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,TRANS_DTYPE) ELSE GLLOP);
IF AFFIX:BYVAR[V] = RNULL THEN
BEGIN
AFFIX:BYVAR[V]←VAR←NEW_RECORD(VARIABLE);
VARIABLE:PLNVAL[VAR]←NEW_FLUENT;
VARIABLE:CALCS[VAR]←NEW_SET_FLUENT;
VARIABLE:DEPS[VAR]←NEW_SET_FLUENT;
VARIABLE:CHANGERS[VAR]←NEW_SET_FLUENT;
VARIABLE:NAME[VAR]←NEW(VAR);
VARIABLE:DATATYPE[VAR]←TRANS_DTYPE;
VARIABLE:BLK[VAR]←GVLBLK
END;
AFFIX:ATEXP[V]←GLLOP;
AFFIX:RIGID[V]←GLLOP;
RETURN(STMAKE(V));
END;
[UNFIXTYPE] BEGIN
V←NEW_RECORD(UNFIX);
UNFIX:FRAME1[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,FRAME_DTYPE) ELSE GLLOP);
UNFIX:FRAME2[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,FRAME_DTYPE) ELSE GLLOP);
RETURN(STMAKE(V));
END;
[GASSIGNTYPE] BEGIN ! Modified by RF;
V←NEW_RECORD(GASSIGN);
GASSIGN:VAR[V]←LLLOP;
IX←CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
GASSIGN:OP[V]←IF IX = "=" THEN 1
ELSE IF IX = "≠" THEN 2
ELSE IF IX = "<" ∨ IX = "←" THEN 3
ELSE 0;
GASSIGN:CLC[V]←GLLOP;
GASSIGN:VAR[V] ←
VTRY(GASSIGN:VAR[V],GET_DTYPE(GASSIGN:CLC[V]));
RETURN(STMAKE(V));
END;
[CALCULATORTYPE] BEGIN
V←NEW_CALC(GLLOP);
CONSON(V,BLOCK:CLCS[GVLBLK]);
RETURN(V);
END;
[CHANGERTYPE] BEGIN
V←BLDCHG(NULL_RECORD,GVLBLK);
CHANGER:CODE[V]←STGROVEL;
RETURN(V);
END;
[ALSODOTYPE] BEGIN
V←NEW_RECORD(ALSODO);
ALSODO:VAR[V] ← VTRY(LLLOP);
ALSOTYPE ← VARIABLE:DATATYPE[ALSODO:VAR[V]];
ALSODO:OP[V] ← 1;
ALSODO:CHG[V] ← NEW_RECORD(CHANGER);
CHANGER:BLID[ALSODO:CHG[V]] ← GVLBLK;
CHANGER:CODE[ALSODO:CHG[V]] ← GLLOP;
CONSON(V,BLOCK:ALSOS[GVLBLK]);
! Doesn't handle the TRIGGERS or NAME fields;
RETURN(STMAKE(V));
END;
[SPECVALTYPE] BEGIN
EXTERNAL RVAR OLDV; ! In HLAREC;
V←NEW_RECORD(SPECVAL);
IF VTRY(LLLOP) = OLDV
THEN SPECVAL:OLD[V] ← TRUE
ELSE SPECVAL:OLD[V] ← FALSE;
RETURN(V);
END;
! grovel: main body: V3ECT, TRANS, ASSIGNMENT, EVDO, PRNT;
[V3ECTTYPE] BEGIN
V←NEW_RECORD(V3ECT);
V3ECT:X[V]←SVAL:VAL[LLLOP];
V3ECT:Y[V]←SVAL:VAL[LLLOP];
V3ECT:Z[V]←SVAL:VAL[LLLOP];
RETURN(V);
END;
[TRANSTYPE] BEGIN
V←NEW_RECORD(TRANS);
TRANS:R[V]←GLLOP;
TRANS:P[V]←GLLOP;
RETURN(V);
END;
[PRNTTYPE] BEGIN "prnt"
V←NEW_RECORD(PRNT);
PRNT:VAL[V] ← LGROVEL(C); ! Gets a list of print items;
RETURN(STMAKE(V));
END "prnt";
[ASSIGNMENTTYPE] BEGIN "assign" ! Modified by RF to check type consistency;
V←NEW_RECORD(ASSIGNMENT);
ASSIGNMENT:VAR[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN LLLOP ELSE GLLOP);
ASSIGNMENT:VAL[V] ← GLLOP;
IF RECTYPE(ASSIGNMENT:VAR[V]) = LOC(IDENT) THEN
ASSIGNMENT:VAR[V] ←
VTRY(ASSIGNMENT:VAR[V],GET_DTYPE(ASSIGNMENT:VAL[V]));
RETURN(STMAKE(V));
END "assign";
[EVDOTYPE] BEGIN
! e.g.: (EV EVAR1 +) will signal the event;
V ← NEW_RECORD(EVDO);
EVDO:VAR[V] ← (IF RECTYPE(CELL:CAR[C])=LOC(IDENT)
THEN VTRY(LLLOP,EVENT_DTYPE) ELSE GLLOP);
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
IF IX = "+"
THEN EVDO:OP[V] ← 0
ELSE IF IX = "-"
THEN EVDO:OP[V] ← 1
ELSE USERERR(1,1,"What kind of EV is " & IX & "?");
RETURN(STMAKE(V));
END;
[CMABLETYPE] BEGIN
! e.g.: (CMABLE + cmon) will enable the cmon;
V ← NEW_RECORD(CMABLE);
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
IF IX = "+" THEN CMABLE:FLAG[V] ← 0
ELSE IF IX = "-" THEN CMABLE:FLAG[V] ← 1
ELSE USERERR(1,1,"What kind of CMABLE is " & IX & "?");
! Get the cmon's label;
IF C≠RNULL THEN ! refers to labelled cmon;
CMABLE:WHAT[V] ← VTRY(LLLOP,OMNLAB_DTYPE)
ELSE ! refers to unlabelled cmon;
IF CCMON ≠ RNULL THEN CMABLE:WHAT[V] ← CCMON
ELSE USERERR(1,1,"Must specify name of cmon.");
RETURN(STMAKE(V));
END;
! grovel: main body: MOVE$, OPERATE, CENTER, STOP, motion clauses;
[MOVE$TYPE] BEGIN "move$" ! Coded by RF;
RANY P;
V ← NEW_RECORD(MOVE$);
MOVE$:WHAT[V] ← GLLOP; ! **** used to be LLLOP
with some comment about
FRAME or SCALAR ****;
MOVE$:DEST[V] ← GLLOP;
MOVE$:DEXP[V] ← NEW_RECORD(DEXPR);
! Can expect VIA, DURATION, CMON, DEPROACHES;
MOVE$:CLAUSES[V] ← LGROVEL(C);
P←MOVE$:CLAUSES[V];
WHILE P ≠ RNULL DO ! All this does is turn CMON & S_FAC;
BEGIN ! statements into regular clauses;
IF RECTYPE(CELL:CAR[P])=LOC(STMNT) THEN
CELL:CAR[P]←STMNT:SEMANTICS[CELL:CAR[P]];
P←CELL:CDR[P];
END;
RETURN(STMAKE(V));
END "move$";
[OPERATETYPE] BEGIN "operate" ! Coded by RF;
V ← NEW_RECORD(OPERATE);
OPERATE:WHAT[V] ← GLLOP;
OPERATE:DEST[V] ← GLLOP;
OPERATE:DEXP[V] ← NEW_RECORD(DEXPR);
! Can expect VIA, DURATION, CMON;
OPERATE:CLAUSES[V] ← LGROVEL(C);
RETURN(STMAKE(V));
END "operate";
[CENTERTYPE] BEGIN "center" ! Coded by RF;
V ← NEW_RECORD(CENTER);
CENTER:CF[V] ← GLLOP;
! Can expect CMON;
CENTER:CLAUSES[V] ← LGROVEL(C);
RETURN(STMAKE(V));
END "center";
[STOPTYPE] BEGIN "stop" ! Coded by RF;
V ← NEW_RECORD(STOP);
STOP:CF[V] ← GLLOP;
RETURN(STMAKE(V));
END "stop";
[CMONTYPE] BEGIN ! Added by RF;
RPTR(CMON) S;
S ← CCMON; ! save outermost cmon;
CCMON ← V ← NEW_RECORD(CMON);
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
IF IX = "+" THEN CMON:FLAGS[V] ← 0 ! Regular cmon;
ELSE IF IX = "-" THEN CMON:FLAGS[V] ← 1 ! Deferred cmon;
ELSE USERERR(1,1,"What kind of CMON is " & IX & "?");
CMON:CONDITION[V] ← GLLOP;
CMON:CONCLUSION[V] ← STGROVEL;
CONSON(V,BLOCK:CMONS[GVLBLK]);
CCMON ← S; ! restore old outermost cmon;
RETURN(STMAKE(V));
END;
[VIATYPE] BEGIN "via" ! Coded by RF;
RANY CLS; ! Clause;
V ← NEW_RECORD(VIA);
VIA:PLACE[V] ← GLLOP;
VERIFY_DTYPE(VIA:PLACE[V],TRANS_DTYPE); ! Check type is ok;
VIA:ACTPLACE[V] ← NEW_RECORD(DEXPR);
WHILE C ≠ RNULL DO
BEGIN
IF RECTYPE(CLS←GLLOP) = LOC(VELOCITY)
THEN VIA:VELOC[V] ← CLS
ELSE IF RECTYPE(CLS) = LOC(DURATION)
THEN VIA:TIME[V] ← CLS
ELSE IF RECTYPE(CLS) = LOC(STMNT)
THEN VIA:CODE[V] ← CLS
ELSE BEGIN ALPRIN(CLS);PRINT(CRLF);
USERERR(1,1,"Funny thing for VIA clause") END;
END;
RETURN(V);
END "via";
[ARRIVALTYPE] BEGIN "arrival" ! coded by ARG;
V ← NEW_RECORD(ARRIVAL);
ARRIVAL:THRU[V] ← GLLOP;
ARRIVAL:ACTPLACE[V] ← NEW_RECORD(DEXPR);
RETURN(V);
END "arrival";
[DEPARTURETYPE] BEGIN "departure" ! coded by ARG;
V ← NEW_RECORD(DEPARTURE);
DEPARTURE:THRU[V] ← GLLOP;
DEPARTURE:ACTPLACE[V] ← NEW_RECORD(DEXPR);
RETURN(V);
END "departure";
[WOBBLETYPE] BEGIN "wobble" ! coded by ARG;
V ← NEW_RECORD(WOBBLE);
WOBBLE:VAL[V] ← GLLOP;
RETURN(V);
END "wobble";
[OPENINGTYPE] BEGIN "opening" ! coded by ARG;
V ← NEW_RECORD(OPENING);
OPENING:VAL[V] ← GLLOP;
RETURN(V);
END "opening";
[DURATIONTYPE] BEGIN "duration" ! Coded by RF;
V ← NEW_RECORD(DURATION);
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
DURATION:TIME_RELN[V] ←
IF IX = ">" THEN 1
ELSE IF IX = "<" THEN 2
ELSE IF IX = "=" THEN 3
ELSE 0;
DURATION:TIME[V] ← GLLOP;
RETURN(V);
END "duration";
[VELOCITYTYPE] BEGIN "velocity" ! coded by ARG;
V ← NEW_RECORD(VELOCITY);
VELOCITY:VELOC[V] ← GLLOP;
RETURN(V);
END "velocity";
[FORCETYPE] BEGIN "force" ! Coded by ARG 5-1-77;
V ← NEW_RECORD(FORCE);
FORCE:DIRECT[V] ← GLLOP;
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
FORCE:REL[V] ← IF IX = "<" THEN SIGLT ELSE SIGGE;
! treat "=" & "≥" the same;
FORCE:VAL[V] ← GLLOP;
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
FORCE:TYPE[V] ← IF IX = "-" THEN FALSE ELSE TRUE;
! force along axis = TRUE, torque about axis = FALSE;
FORCE:F_F[V] ← GLLOP; ! Get force frame spec;
RETURN(V);
END "force";
[F_FRAMETYPE] BEGIN "force frame"
V ← NEW_RECORD(F_FRAME);
F_FRAME:FRAME[V] ← GLLOP;
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
F_FRAME:C_SYS[V] ← IF IX = "⊗" THEN FHAND ELSE FTABLE;
RETURN(V);
END "force frame";
[SETBASETYPE] BEGIN "setbase" ! This and WRIST below are temp hacks;
V ← NEW_RECORD(SETBASE);
RETURN(STMAKE(V));
END "setbase";
[WRISTTYPE] BEGIN "wrist"
V ← NEW_RECORD(WRIST);
WRIST:VAL[V] ← GLLOP;
RETURN(STMAKE(V));
END "wrist";
[S_FACTYPE] BEGIN "speed_factor" ! coded by ARG;
V ← NEW_RECORD(S_FAC);
S_FAC:VAL[V] ← GLLOP;
RETURN(STMAKE(V));
END "speed_factor";
[NNULLTYPE] BEGIN "nnull"
V ← NEW_RECORD(NNULL);
IX ← CHAR_REC:CHAR[CHKREC(LLLOP,LOC(CHAR_REC))];
NNULL:FLAG[V] ← IF IX = "+" THEN TRUE ELSE FALSE;
RETURN(V);
END "nnull";
[0] RETURN(NULL_RECORD)
END;
END;
[0] END;
RETURN(SE);
END;
! MAIN PROGRAM;
IFCR FALSE THENC
WHILE TRUE DO
BEGIN "REP"
EXTERNAL PROCEDURE BAIL;
RANY R;
BAIL;
PRINT(CRLF);
R←READ;
ALPRIN(GROVEL(R));
PRINT(CRLF);
END;
ENDC
END $$PRGID;